home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / prelude / PreludeDynamic.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  34.7 KB  |  986 lines  |  [TEXT/YHS2]
  1. {-
  2.  
  3. This is the Yale dynamic typing extension to Haskell.
  4.  
  5. To use dynamic typing, you need to import the module Dynamic.
  6.  
  7. The following data types are defined here:
  8.  
  9. Dynamic       a value encoded as a dynamic
  10. Signature     the type of a dynamic object (this has class constraints)
  11. Type          this is used in the body of a signature
  12. DynamicError  a distinguished type returned by dynamic operations which fail
  13. DataType      represents a data declaration
  14. Constructor   contained in DataType
  15. Class         represents a class declaration
  16. Instance      represents an instance declaration
  17. Fixity        represents a fixity declaration
  18. Symbol        hashed strings with fast equality (also in the Symbol module)
  19.  
  20. The following operations are defined in Dynamic:
  21.  
  22.   Special operations implemented within the type checker:
  23.  
  24. toDynamic :: a -> Dynamic
  25. fromDynamic :: Dynamic -> a
  26. typeOf :: a -> Signature
  27.  
  28. Dynamic pattern matching has the syntax (pat :: Sig).  This matches a
  29. Dynamic value with the specified signature.
  30.  
  31.   Functions which probe the static type system:
  32.    
  33. dDataTypeName      :: DataType -> String  -- Name in data declaration
  34. dDataTypeFullName  :: DataType -> Symbol -- includes module
  35. dDataTypeArity     :: DataType -> Int
  36. dDataTypeConstrs   :: DataType -> [Constructor]
  37. dDataTypeTuple     :: DataType -> Bool  -- True for single constr types
  38. dDataTypeEnum      :: DataType -> Bool  -- True for enumerated types
  39. dDataTypeRealTuple :: DataType -> Bool  -- True for real tuples
  40. dDataTypeInstances :: DataType -> [Instance] 
  41.  
  42. dConstructorName       :: Constructor -> String
  43. dConstructorTag        :: Constructor -> Int  -- Numbered in order of data decl
  44. dConstructorFixity     :: Constructor -> Fixity
  45. dConstructorType       :: Constructor -> DataType
  46. dConstructorSignature  :: Constructor -> Signature
  47. dConstructorArity      :: Constructor -> Int
  48. dConstructorStrictness :: Constructor -> [Bool]
  49. dConstructorInfix      :: Constructor -> Bool  -- declared using infix notation
  50.  
  51. dClassName         :: Class -> String
  52. dClassFullName     :: Class -> Symbol
  53. dClassSuperClasses :: Class -> [Class]
  54.  
  55. dInstanceType     :: Instance -> DataType
  56. dInstanceClass    :: Instance -> Class
  57. dInstanceContext  :: Instance -> [[Class]]
  58.  
  59. -------------------------------
  60.  
  61.   The following functions operate in the dynamic domain
  62.  
  63. dType           :: Dynamic -> Signature
  64.   returns the type of a dynamic value
  65. dDataType       :: Dynamic -> DataType
  66.   returns the top level type of a value, a DataType.  This will fail
  67.   when an object of type 'a' is encountered.
  68. dHasDataType    :: Dynamic -> Bool
  69.   True when the object is not of type 'a'
  70. dConstructor    :: Dynamic -> Bool
  71.   Evaluates the dynamic value and returns the constructor which created the
  72.   value.  The object must have a dataType.  Forcing occurs even for tuple types.
  73. dSlots          :: Dynamic -> [Dynamic]
  74.   Returns the components of a data value as a list of dynamic objects.
  75. dSlotTypes      :: Constructor -> Signature -> [Signature]
  76.   Similar to dSlots except just the types of the slots are returned.  Instead
  77.   of a dynamic, the arguments are the constructor the signature of the object.
  78. dApply          :: Dynamic -> [Dynamic] -> Dynamic
  79.   This performs a single function application.  A 'DynamicError' is returned
  80.   if the function and arguments are not of the correct type.  All overloading
  81.   of the function and all arguments must be resolved via the types.  The
  82.   result will never be overloaded.
  83. dApplyType :: Signature -> [Signature] -> Signature
  84.   Similar to dApply except only the result type is computed.
  85. dBuild          :: Constructor -> [Dynamic] -> Dynamic
  86.   Build a new data value from a constructor and a set of dynamic arguments.
  87. genTupleType    :: Int -> DataType
  88.   Returns the DataType associated with tuples of a given size.
  89. dCoerce         :: Dynamic -> Signature -> Dynamic
  90.   Coerce the value of a dynamic to a given signature.  The result cannot be
  91.   overloaded.
  92. dShow           :: Dynamic -> String
  93.   This is similar to show except that it does not depend on the Text
  94.   instance and can be used on objects of any type.
  95.  
  96. Notes:
  97.  
  98. An overview of this dynamic typing system can be found in a Yale Tech report.
  99.  
  100. A number of extensions could be easily added:
  101.  
  102.   the result of dApply and dCoerce could be allowed to be overloaded.
  103.  
  104.   unification of existential types could be permitted.  Right now,
  105.     f (x :: Num a => a) (y :: Num a => a) = toDynamic (x+y)
  106.   will not work since x and y have differing existential types.  What
  107.   this should do is add a guard to the pattern match for y to ensure
  108.   the two dynamic types are the same.  Right now you have to do
  109.     d (x :: Num a => a) y = toDynamic (x + fromDynamic y)
  110.   which is needlessly obscure.
  111.  
  112.   some way of combining Haskell signatures and variables bound to signatures
  113.   would be nice.  Right now dApplyType and dSlotTypes are the only ways of
  114.   computing at the signature level.
  115.  
  116.   Unsafe versions of dSlots, dApply, and others would be nice in code where
  117.   type errors are not possible.
  118.  
  119. Safety checks needed to be added to the type checker to prevent
  120. existential types from escaping their scope. Right now,
  121.   f (x :: Num a => a) = a
  122. is not caught by the compiler.  The inferred type would be
  123.   f :: Dynamic -> Txxxx
  124. where Txxxx is an existential type used in the type checker.  Since this
  125. won't type check with anything there will be a type error, although somewhat
  126. removed from the actual source of the error.  Worse is that toDynamic can
  127. be placed outside the scope of the dynamic pattern - this probably will croak
  128. the compiler:
  129.   f x = toDynamic (g x) where g (z :: Text a => a) = z
  130.  
  131. Unlike data types, the class system does not export its operations to
  132. the dynamic domain.  It would be pretty easy to add a list of class methods
  133. to the Class object.
  134.  
  135. This whole thing is rather slow!  Don't expect dynamic operations to go
  136. too fast.
  137.  
  138. The following Haskell code needs cleaning up.
  139.  
  140. -}
  141.  
  142. module Dynamic(Dynamic, Signature(..), Type(..), DynamicError(..), Context(..),
  143.                DataType, Constructor, Class, Instance, Fixity(..), Symbol,
  144.                toDynamic, fromDynamic, typeOf,
  145.  
  146.                dDataTypeName, dDataTypeFullName, dDataTypeArity,
  147.                dDataTypeConstrs, dDataTypeTuple, dDataTypeEnum,
  148.                dDataTypeRealTuple, dDataTypeInstances, 
  149.                
  150.                dConstructorName, dConstructorTag, dConstructorFixity, 
  151.                dConstructorType, dConstructorSignature, dConstructorArity, 
  152.                dConstructorStrictness, dConstructorInfix, 
  153.  
  154.                dClassName, dClassFullName, dClassSuperClasses, 
  155.  
  156.                dInstanceType, dInstanceClass, dInstanceContext, 
  157.  
  158.                dType, dConstructor, dSlots, dBuild, dHasDataType, 
  159.                genTupleType, dApply, dShow, dDataType, 
  160.       
  161.                EnumType(..), EnumOrTupleType(..)
  162.              )
  163.    where 
  164.  
  165. import DynamicInternal
  166. import Symbol
  167.  
  168. {-# Prelude #-}
  169.  
  170. module DynamicInternal where
  171.  
  172. {-# Prelude #-}
  173.  
  174. import Symbol
  175. import DynamicPrims
  176. import PreludeTuplePrims
  177.  
  178. class EnumType a
  179.  
  180. class EnumOrTupleType a
  181.  
  182. class DynamicType a  -- Used as a marker for type variables.
  183.  
  184. data Magic = Magic
  185. instance Text(Magic) where
  186.   showsPrec _ _ = showString "Magic"
  187.  
  188. data Dynamic = MkDynamic Signature {-#STRICT#-} Magic
  189.  
  190. instance Text(Dynamic) where
  191.   showsPrec p (MkDynamic ty _) = 
  192.     showString "Dynamic " . shows ty
  193.  
  194. {- Captured type signatures are represented by these types -}
  195.  
  196. type Context = [Class]
  197.  
  198. data Signature {-#STRICT#-} = MkSignature [Context] Type
  199.  
  200. instance Text(Signature) where
  201.   showsPrec p s = showParen (p > 9) (showSig s)
  202.  
  203. showSig :: Signature -> ShowS
  204. showSig (MkSignature ctxt ty) = showContext ctxt . showType ty
  205.  
  206. showContext :: [[Class]] -> ShowS
  207. showContext ctxt | all null ctxt = id
  208. showContext ctxt = maybeParen ctxts . showString " => "
  209.   where
  210.     maybeParen [s] = showString s
  211.     maybeParen (x : xs) =
  212.          showChar '(' . showString x . showRest xs . showChar ')'
  213.     showRest [] = id
  214.     showRest (x:xs) = showChar ',' . showString x . showRest xs
  215.     vars = zip ctxt ['a'..]
  216.     ctxts = concat
  217.              (map (\(c,v) -> map (\cl -> dClassName cl ++ " " ++ [v]) c) vars)
  218.  
  219.  
  220. data Type {-#STRICT#-} = Tycon DataType [Type] |
  221.                          Tyvar Int |
  222.                          BTyvar Int Context
  223.  
  224. instance Text(Type) where
  225.   showsPrec p s = showParen (p > 9) (showType s)
  226.  
  227. showType :: Type -> ShowS
  228. showType ty = showType' ty False
  229.  
  230. showType' (Tyvar i) _ = showChar (chr (ord 'a' + i))
  231. showType' (Tycon ty _) _ | ty == unitType = showString "()"
  232. showType' (Tycon ty [x]) _ | ty == listType =
  233.      showChar '[' . showType' x False . showChar ']'
  234. showType' (Tycon ty [f,a]) p | ty == fnType =
  235.   showParen p (showType'' f . showString " -> " . showType' a False) where
  236.     showType'' t@(Tycon ty [f,a]) | ty == fnType = showType' t True
  237.     showType'' ty = showType' ty False
  238. showType' (Tycon ty (t:ts)) _ | dDataTypeRealTuple ty = 
  239.   showChar '(' . showType' t False . showTuple ts . showChar ')' where
  240.    showTuple [] = id
  241.    showTuple (t:ts) = showChar ',' . showType' t False . showTuple ts
  242. showType' (Tycon ty []) _ = showString (dDataTypeName ty)
  243. showType' (Tycon ty types) p = 
  244.   showParen p (showString (dDataTypeName ty) . showArgs types) where
  245.    showArgs [] = id
  246.    showArgs (t:ts) = showChar ' ' . showType' t True . showArgs ts
  247.  
  248. bot = error "Bottom"
  249.  
  250. charType = dDataType (toDynamic 'a')
  251. intType = dDataType (toDynamic (1 :: Int))
  252. integerType = dDataType (toDynamic (1 :: Integer))
  253. floatType = dDataType (toDynamic (1 :: Float))
  254. doubleType = dDataType (toDynamic (1 :: Double))
  255. listType = dDataType (toDynamic "a")
  256. fnType = dDataType (toDynamic id)
  257. unitType = dDataType (toDynamic ())
  258.  
  259. textClass = gClass (typeOf (bot :: Text a => a))
  260. binClass = gClass (typeOf (bot :: Binary a => a))
  261. eqClass = gClass (typeOf (bot :: Eq a => a))
  262. ordClass = gClass (typeOf (bot :: Ord a => a))
  263. ixClass = gClass (typeOf (bot :: Ix a => a))
  264. enumClass = gClass (typeOf (bot :: Enum a => a))
  265.  
  266. gClass (MkSignature [[c]] _) = c
  267.  
  268. {- This is used to denote runtime type errors -}
  269.  
  270. data DynamicError = DynamicError String
  271.    deriving Text
  272.  
  273. {- This is used to define the fixity of a constructor -}
  274.  
  275. data Fixity {-#STRICT#-} = InfixL Int |
  276.                            InfixR Int |
  277.                            InfixN Int |
  278.                            NoFixity
  279.   deriving Text
  280.  
  281. {- These data structures define the type environment.  The compiler
  282.    creates values of these types for use at runtime by the dynamic
  283.    type checker -}
  284.  
  285. data DataType = MkDataType 
  286.   String  {-#STRICT#-} -- type name
  287.   Symbol  {-#STRICT#-} -- full type name
  288.   Int     {-#STRICT#-} -- arity
  289.   [Constructor]
  290.   Bool    {-#STRICT#-} -- tuple?
  291.   Bool    {-#STRICT#-} -- enum?
  292.   Bool    {-#STRICT#-} -- real-tuple  
  293.   [Instance]
  294.   Magic  -- constructor function
  295.  
  296. instance Text(DataType) where
  297.   showsPrec p s = showParen (p > 9)
  298.                    (showString ("type " ++ dDataTypeName s))
  299.  
  300. instance Eq(DataType) where
  301.   ty1 == ty2 = dDataTypeFullName ty1 == dDataTypeFullName ty2
  302.  
  303. dDataTypeName      (MkDataType x _ _ _ _ _ _ _ _) = x
  304. dDataTypeFullName  (MkDataType _ x _ _ _ _ _ _ _) = x
  305. dDataTypeArity     (MkDataType _ _ x _ _ _ _ _ _) = x
  306. dDataTypeConstrs   (MkDataType _ _ _ x _ _ _ _ _) = x
  307. dDataTypeTuple     (MkDataType _ _ _ _ x _ _ _ _) = x
  308. dDataTypeEnum      (MkDataType _ _ _ _ _ x _ _ _) = x
  309. dDataTypeRealTuple (MkDataType _ _ _ _ _ _ x _ _) = x
  310. dDataTypeInstances (MkDataType _ _ _ _ _ _ _ x _) = x
  311. dDataTypeGetCon    (MkDataType _ _ _ _ _ _ _ _ x) = x
  312.  
  313. {-# dDataTypeName :: Inline
  314.     dDataTypeFullName :: Inline
  315.     dDataTypeArity :: Inline
  316.     dDataTypeConstrs :: Inline
  317.     dDataTypeTuple :: Inline
  318.     dDataTypeEnum :: Inline
  319.     dDataTypeRealTuple :: Inline
  320.     dDataTypeInstances :: Inline
  321.     dDataTypeGetCon :: Inline  #-}
  322.  
  323. data Constructor = MkConstructor
  324.   String    {-#STRICT#-} -- Name
  325.   Int       {-#STRICT#-} -- Tag number
  326.   Fixity    {-#STRICT#-} -- Fixity
  327.   Signature {-#STRICT#-} -- signature
  328.   Magic     -- Constructor Fn
  329.   [Magic]   {-#STRICT#-} -- Selector Fns
  330.   DataType  -- back pointer to data type
  331.   [Bool]    {-#STRICT#-} -- strictness signature
  332.   Int       {-#STRICT#-} -- arity
  333.   Bool      {-#STRICT#-} -- infix?
  334.  
  335. instance Text(Constructor) where
  336.   showsPrec p s = showParen (p > 9)
  337.                    (showString ("constructor " ++ dConstructorName s))
  338.  
  339. dConstructorName       (MkConstructor x _ _ _ _ _ _ _ _ _) = x
  340. dConstructorTag        (MkConstructor _ x _ _ _ _ _ _ _ _) = x
  341. dConstructorFixity     (MkConstructor _ _ x _ _ _ _ _ _ _) = x
  342. dConstructorSignature  (MkConstructor _ _ _ x _ _ _ _ _ _) = x
  343. dConstructorConstrFn   (MkConstructor _ _ _ _ x _ _ _ _ _) = x
  344. dConstructorSelectors  (MkConstructor _ _ _ _ _ x _ _ _ _) = x
  345. dConstructorType       (MkConstructor _ _ _ _ _ _ x _ _ _) = x
  346. dConstructorStrictness (MkConstructor _ _ _ _ _ _ _ x _ _) = x
  347. dConstructorArity      (MkConstructor _ _ _ _ _ _ _ _ x _) = x
  348. dConstructorInfix      (MkConstructor _ _ _ _ _ _ _ _ _ x) = x
  349.  
  350. {-# dConstructorName :: Inline
  351.     dConstructorTag :: Inline
  352.     dConstructorFixity :: Inline
  353.     dConstructorSignature :: Inline
  354.     dConstructorConstrFn :: Inline
  355.     dConstructorSelectors :: Inline
  356.     dConstructorType :: Inline
  357.     dConstructorStrictness :: Inline
  358.     dConstructorArity :: Inline
  359.     dConstructorInfix :: Inline  #-}
  360.  
  361. data Class = MkClass
  362.   String     {-#STRICT#-} -- Name
  363.   Symbol     {-#STRICT#-} -- Full Name
  364.   [Class] -- Super* classes
  365.   [Magic]    {-#STRICT#-} -- Dictionary selectors as indexed by classes
  366.  
  367. instance Text(Class) where
  368.   showsPrec p s = showParen (p > 9)
  369.                    (showString ("class " ++ dClassName s))
  370.  
  371. instance Eq(Class) where
  372.   ty1 == ty2 = dClassFullName ty1 == dClassFullName ty2
  373.  
  374. dClassName         (MkClass x _ _ _) = x
  375. dClassFullName     (MkClass _ x _ _) = x
  376. dClassSuperClasses (MkClass _ _ x _) = x
  377. dClassDictSels     (MkClass _ _ _ x) = x
  378.  
  379. {-# dClassName :: Inline
  380.     dClassFullName :: Inline
  381.     dClassSuperClasses :: Inline
  382.     dClassDictSels :: Inline  #-}
  383.     
  384. data Instance = MkInstance
  385.   DataType 
  386.   Class
  387.   Magic               -- Dictionary
  388.   [Context]           -- constraints on data type
  389.  
  390. instance Text(Instance) where
  391.   showsPrec p s = showParen (p > 9)
  392.                    (showString ("instance " ++ cl ++ "(" ++ ty ++ ")"))
  393.     where cl = dClassName (dInstanceClass s)
  394.           ty = dDataTypeName (dInstanceType s)
  395.  
  396. dInstanceType    (MkInstance x _ _ _) = x
  397. dInstanceClass   (MkInstance _ x _ _) = x
  398. dInstanceDict    (MkInstance _ _ x _) = x
  399. dInstanceContext (MkInstance _ _ _ x) = x
  400.  
  401. {-# dInstanceType :: Inline
  402.     dInstanceClass :: Inline
  403.     dInstanceDict :: Inline
  404.     dInstanceContext :: Inline  #-}
  405.  
  406. genTupleType :: Int -> DataType
  407. genTupleType i = tupleTypes !! (i-2)
  408.  
  409. tupleTypes = mkTuples 2
  410. mkTuples i = mkTuple i : mkTuples (i+1)
  411.  
  412. mkTuple i = t where
  413.    t = MkDataType tupName tupSym i [tupCon] True False True insts
  414.                   (toMagic forcefn)
  415.    tupSym = stringToSymbol tupName
  416.    tupName = "(" ++ take (i-1) (repeat ',') ++ ")"
  417.    forcefn = \m -> case m of Magic -> tupCon  -- This forces the tuple.
  418.    tupCon = MkConstructor
  419.                conName 0 NoFixity ty confn selfns t strict i False
  420.     where
  421.      conName = tupName
  422.      ty = MkSignature (take i (repeat [])) (arrows 0)
  423.      arrows x | x == i = Tycon t (map Tyvar [0 .. i-1])
  424.      arrows x = Tycon fnType [Tyvar x,arrows (x+1)]
  425.      confn = makeTupleCon i
  426.      selfns = map (\j -> makeTupleSel i j) [0..(i-1)]
  427.      strict = take i (repeat False)
  428.    insts = fetchInstances t allInstances
  429.    
  430. -- This may create redundant instances but so what?!?
  431.  
  432. buildSkolem :: [(Class,Magic)] -> Type
  433. buildSkolem classes = Tycon ty [] where
  434.   n = genSymbol "type"
  435.   ty = MkDataType (symbolToString n) n 0 [] False False False insts e
  436.   e = error "Hidden type"
  437.   insts = concat (map (\(c,d) -> genInstances c d) classes)
  438.   genInstances c d = mkInst c d : (zipWith genSuper (dClassSuperClasses c)
  439.                                                     (dClassDictSels c)) where
  440.      genSuper sc dsel = mkInst sc (primApply dsel d)
  441.   mkInst c d = MkInstance ty c d []
  442.  
  443. dValue (MkDynamic _ v) = v
  444.  
  445. -- ------  Entry points into the system ------------
  446.  
  447. -- Special functions handled in the compiler:
  448.  
  449. typeOf :: a -> Signature
  450. typeOf = error "Compiler missed typeOf primitive!"
  451.  
  452. toDynamic :: a -> Dynamic
  453. toDynamic = error "Compiler missed toDynamic!"
  454.  
  455. fromDynamic :: Dynamic -> a
  456. fromDynamic = error "Compiler missed fromDynamic!"
  457.  
  458. -- Regular functions:
  459.  
  460. dType :: Dynamic -> Signature
  461. dType (MkDynamic ty _) = ty
  462.  
  463. dDataType :: Dynamic -> DataType
  464. dDataType x = case dType x of
  465.    MkSignature _ (Tycon ty _) -> ty
  466.    _ -> error "dDataType error: type is 'a'"
  467.  
  468. dHasDataType :: Dynamic -> Bool
  469. dHasDataType x = case dType x of
  470.    MkSignature _ (Tycon ty _) -> True
  471.    _ -> False
  472.  
  473. dConstructor :: Dynamic -> Constructor
  474. dConstructor x =
  475.  fromMagic
  476.   (primApply (dDataTypeGetCon (dDataType x)) (dValue x)) :: Constructor
  477.  
  478. dSlots :: Dynamic -> [Dynamic]
  479. dSlots x = zipWith getSlot allTypes (dConstructorSelectors c) where
  480.   c = dConstructor x
  481.   dv = dValue x
  482.   MkSignature valCtxt valType = dType x
  483.   MkSignature conCtxt conType = dConstructorSignature c
  484.   arity = dConstructorArity c
  485.   argTypes = map Tyvar [0..arity-1]
  486.   env1 = take arity (repeat (UnBound []))
  487.   (vt,env2) = renameVars valCtxt valType env1
  488.   (ct,env3) = renameVars conCtxt conType env2
  489.   DSucc env = unify' (makeApp argTypes vt) ct env3
  490.   getSlot t fn = MkDynamic t (primApply fn dv)
  491.   allTypes = map (\t -> reconstructSig t env) argTypes
  492.  
  493. dSlotTypes :: Constructor -> Signature -> [Signature]
  494. dSlotTypes c s = map (\t -> reconstructSig t env) argTypes where
  495.   MkSignature valCtxt valType = s
  496.   MkSignature conCtxt conType = dConstructorSignature c
  497.   arity = dConstructorArity c
  498.   argTypes = map Tyvar [0..arity-1]
  499.   env1 = take arity (repeat (UnBound []))
  500.   (vt,env2) = renameVars valCtxt valType env1
  501.   (ct,env3) = renameVars conCtxt conType env2
  502.   DSucc env = unify' (makeApp argTypes vt) ct env3
  503.  
  504. makeApp [] res = res
  505. makeApp (a:args) res = Tycon fnType [a,makeApp args res]
  506.  
  507. dApply :: Dynamic -> [Dynamic] -> Dynamic
  508. dApply fn args = getResult cEnv where
  509.   MkSignature fContext fType = dType fn
  510.   initialEnv = (map UnBound fContext)
  511.   res = length initialEnv -- Tyvar for result
  512.   (args',env) = remapTyvars args (initialEnv ++ [UnBound []])
  513.   remapTyvars [] e = ([],e)
  514.   remapTyvars (MkDynamic (MkSignature c1 t1) v : args) e =
  515.     ((v,c1,k,t):a,e'') where
  516.        (t,e') = renameVars c1 t1 e
  517.        (a,e'') = remapTyvars args e'
  518.        k = length e
  519.   argTypes = getArgTypes args' where
  520.     getArgTypes [] = Tyvar res
  521.     getArgTypes ((_,_,_,t):ts) = Tycon fnType [t,getArgTypes ts]
  522.   cEnv = unify' fType argTypes env
  523.   getResult (DFailure s) = toDynamic (DynamicError s)
  524.   getResult (DSucc env) | ambiguous env =
  525.      toDynamic (DynamicError "Ambiguous type")
  526.                         | otherwise = MkDynamic newType newVal where
  527.        ambiguous [] = False
  528.        ambiguous ((Bound _):tys) = ambiguous tys
  529.        ambiguous ((UnBound []):tys) = ambiguous tys
  530.        ambiguous _ = True
  531.        newType = reconstructSig (Tyvar res) env
  532.        newVal = primApplyList fVal argVals
  533.        fVal = resolveOL fContext 0 env (dValue fn)
  534.        argVals = map (\(v,c,k,t) -> resolveOL c k env v) args'
  535.  
  536. resolveOL [] _ _ val = val
  537. resolveOL ctxt k env val =
  538.   applyToDicts (getTypes k ctxt) ctxt val where
  539.     getTypes k [] = []
  540.     getTypes k (t:ts) = r (Tyvar k) : getTypes (k+1) ts
  541.     r (Tycon ty types) = Tycon ty (map r types)
  542.     r (Tyvar i) = s (lookupEnv i env) i
  543.     s (Bound ty) i = r ty
  544.     s (UnBound _) i = Tyvar i
  545.  
  546. dApplyType :: Signature -> [Signature] -> Signature
  547. dApplyType fn args = getResult cEnv where
  548.   MkSignature fContext fType = fn
  549.   initialEnv = (map UnBound fContext)
  550.   res = length initialEnv -- Tyvar for result
  551.   (args',env) = remapTyvars args (initialEnv ++ [UnBound []])
  552.   remapTyvars [] e = ([],e)
  553.   remapTyvars ((MkSignature c1 t1) : args) e = (t:a,e'') where
  554.        (t,e') = renameVars c1 t1 e
  555.        (a,e'') = remapTyvars args e'
  556.   argTypes = makeApp args' (Tyvar res)
  557.   cEnv = unify' fType argTypes env
  558.   getResult (DFailure s) = typeOf (DynamicError s)
  559.   getResult (DSucc env) = reconstructSig (Tyvar res) env
  560.  
  561. dBuild :: Constructor -> [Dynamic] -> Dynamic
  562. dBuild c args = dApply (MkDynamic (dConstructorSignature c)
  563.                                   (dConstructorConstrFn c))
  564.                        args
  565.  
  566. -- -- -- -- --   Unification stuff   -- -- -- --
  567.  
  568. data VBinding {-#STRICT#-} = UnBound Context | Bound Type
  569.   deriving Text
  570.  
  571. type Env = [VBinding]
  572.  
  573. data WithError a {-#STRICT#-} = DSucc a | DFailure String
  574.   deriving Text
  575.  
  576. seqErr :: WithError b -> (b -> WithError a) -> WithError a
  577. seqErr (DFailure s) _ = DFailure s
  578. seqErr (DSucc s) f = f s
  579.  
  580. locateInstance :: DataType -> Class -> WithError Instance
  581. locateInstance ty c = f (dDataTypeInstances ty) where
  582.   f [] = DFailure ("Type " ++ dDataTypeName ty ++ " is not in class "
  583.                        ++ dClassName c)
  584.   f (i:insts) | c == dInstanceClass i = DSucc i
  585.               | otherwise = f insts
  586.  
  587. unifyB :: Signature -> Signature -> WithError ([Type],[Type])
  588. unifyB (MkSignature c1 t1) (MkSignature c2 t2) =
  589.  unify' t1 t2' env `seqErr` 
  590.      (\env' -> let b = substituteBindings env' in
  591.                  DSucc (take n b, drop n b))
  592.    where
  593.      n = length c1
  594.      (t2',env) = renameVars c2 t2 (map UnBound c1)
  595.  
  596. unify' :: Type -> Type -> Env -> WithError Env
  597. unify' ty1 ty2 env = unify'' (deref ty1 env) (deref ty2 env) env
  598.  
  599. unify'' :: Type -> Type -> Env -> WithError Env
  600. unify'' (Tycon t1 args1) (Tycon t2 args2) env =
  601.   if t1 == t2
  602.     then unifyList args1 args2 env
  603.     else DFailure ("Type " ++ dDataTypeName t1 ++ " does not match " ++
  604.                           dDataTypeName t2)
  605. unify'' (Tyvar v1) ty@(Tycon _ _) env = unifyVT v1 (lookupEnv v1 env) ty env
  606. unify'' ty@(Tycon _ _) (Tyvar v1) env = unifyVT v1 (lookupEnv v1 env) ty env
  607. unify'' (Tyvar v1) (Tyvar v2) env
  608.      | v1 == v2 = DSucc env
  609.      | otherwise = unifyVV v1 v2 (lookupEnv v1 env) (lookupEnv v2 env) env
  610.  
  611. unifyList :: [Type] -> [Type] -> Env -> WithError Env
  612. unifyList [] _ env = DSucc env
  613. unifyList (t1 : t1s) (t2 : t2s) env =
  614.   unify' t1 t2 env `seqErr` (\env' -> unifyList t1s t2s env')
  615.  
  616. unifyVT :: Int -> VBinding -> Type -> Env -> WithError Env
  617. unifyVT v (UnBound ctxt) ty env =
  618.    reduceContext ty ctxt env `seqErr` 
  619.     (\env' -> DSucc (updateEnv v (Bound ty) env'))
  620.  
  621. unifyVV v1 v2 (UnBound ctxt) ty env =
  622.   let env' = updateEnv v1 (Bound (Tyvar v2)) env in
  623.     reduceContext (Tyvar v2) ctxt env'
  624.  
  625. -- Warning: the treatment of type variables here is bogus.  A lot needs
  626. -- to be done to make them work they way they should.
  627.  
  628. substituteBindings env = zipWith s env [0..] where
  629.   r (Tycon ty types) = Tycon ty (map r types)
  630.   r (Tyvar i) = s (lookupEnv i env) i
  631.   s (Bound ty) i = r ty
  632.   s (UnBound c) i = BTyvar i c
  633.                 
  634. -- This creates a signature from type and environment
  635.  
  636. reconstructSig ty [] = MkSignature [] ty
  637. reconstructSig ty env =
  638.      MkSignature (map (\i -> g (lookupEnv i env)) env') newTy where
  639.   g (UnBound c) = c
  640.   (newTy,env') = r ty []
  641.   r (Tyvar i) env' = s (lookupEnv i env) i env'
  642.   r (Tycon d types) env' = (Tycon d tys,env'') where
  643.      (tys,env'') = rl types env'
  644.   rl [] env' = ([],env')
  645.   rl (t:ts) env' = (t':ts',env3) where
  646.        (t',env2) = r t env'
  647.        (ts',env3) = rl ts env2
  648.   s (Bound ty) i env' = r ty env'
  649.   s (UnBound _) i env' = (Tyvar j,env'') where
  650.     (j,env'') = augmentEnv env' 0
  651.     augmentEnv [] l = (l,env' ++ [i])
  652.     augmentEnv (k:e') l | k == i = (l,env')
  653.                         | otherwise = augmentEnv e' (l+1)
  654.   
  655. -- This is way ugly.  This dereferences type variables, renumbers
  656. -- type variables, and returns the bindings of the type variables in
  657. -- the type.
  658.  
  659. lookupEnv :: Int -> Env -> VBinding
  660. lookupEnv n e = e !! n
  661.  
  662. updateEnv :: Int -> VBinding -> Env -> Env
  663. updateEnv 0 x (b:bs) = x:bs
  664. updateEnv (n+1) x (b:bs) = b:updateEnv n x bs
  665.  
  666. classImplies :: Class -> Class -> Bool
  667. classImplies c1 c2 = any (== c2) (c1 : (dClassSuperClasses c1))
  668.  
  669. contextImplies :: Context -> Class -> Bool
  670. contextImplies ctxt c = any (\c1 -> classImplies c1 c) ctxt
  671.  
  672. mergeContext :: Context -> Class -> Context
  673. mergeContext ctxt c =
  674.     c : filter (\cl -> not (classImplies c cl)) ctxt
  675.  
  676. reduceContext :: Type -> Context -> Env -> WithError Env
  677. reduceContext ty [] env = DSucc env
  678. reduceContext ty (c:classes) env =
  679.  reduceContext1 ty c env `seqErr` (\env' -> reduceContext ty classes env')
  680.  
  681. reduceContext1 (Tycon ty args) c env =
  682.   locateInstance ty c `seqErr`
  683.   (\inst -> reduceContext2 args (dInstanceContext inst) env)
  684. reduceContext1 (Tyvar i) c env =
  685.   case lookupEnv i env of
  686.     (Bound t) -> reduceContext1 t c env
  687.     (UnBound ctxt) -> DSucc 
  688.                         (updateEnv i (UnBound (mergeContext ctxt c)) env)
  689.  
  690. reduceContext2 [] _ env = DSucc env
  691. reduceContext2 (t:types) (c:contexts) env =
  692.   reduceContext t c env `seqErr` (\env' -> reduceContext2 types contexts env')
  693.  
  694. deref :: Type -> Env -> Type
  695. deref ty@(Tyvar v) env = case lookupEnv v env of
  696.    (Bound ty') -> deref ty' env
  697.    _          -> ty
  698. deref ty env = ty
  699.  
  700. renameVars :: [Context] -> Type -> Env -> (Type,Env)
  701. renameVars [] ty env = (ty,env)
  702. renameVars c ty env = (renumberTyvars ty,env ++ map UnBound c) where
  703.   n = length env
  704.   renumberTyvars (Tycon ty args) = Tycon ty (map renumberTyvars args)
  705.   renumberTyvars (Tyvar i) = Tyvar (i+n)
  706.  
  707.  
  708. --  Used in support.  Type inference assures that the lookup will succeed.
  709.  
  710. fetchInstances :: DataType -> [Instance] -> [Instance]
  711.  
  712. fetchInstances ty insts | dDataTypeRealTuple ty = addTupleInsts ty insts'
  713.                         | otherwise = insts' where
  714.   insts' = filter (\i -> dInstanceType i == ty) insts
  715.  
  716. addTupleInsts ty insts = 
  717.   maybeAdd textClass tupleTextDict ++
  718.   maybeAdd eqClass tupleEqDict ++
  719.   maybeAdd ordClass tupleOrdDict ++
  720.   maybeAdd ixClass tupleIxDict ++
  721.   maybeAdd binClass tupleBinaryDict ++ insts where
  722.     maybeAdd cl dict | any (\inst -> dInstanceClass inst == cl) insts = []
  723.                      | otherwise = [makeTupleInst cl ty dict i]
  724.     i = dDataTypeArity ty
  725.  
  726. makeTupleInst cl ty d n = 
  727.   MkInstance ty cl d (take n (repeat [cl]))
  728.  
  729. coerce :: Dynamic -> Signature -> WithError Magic
  730. coerce val ty = case (unifyB (dType val) ty) of
  731.    DFailure s -> DFailure s
  732.    DSucc ([],_) -> DSucc (dValue val)
  733.    DSucc (binds,_) -> DSucc (applyToDicts binds ctxts (dValue val)) where
  734.      MkSignature ctxts _ = dType val
  735.  
  736. dCoerce :: Dynamic -> Signature -> Dynamic
  737. dCoerce val ty = case coerce val ty of
  738.   DFailure s -> toDynamic (DynamicError s)
  739.   DSucc m -> MkDynamic ty m
  740.  
  741. coerceB :: Dynamic -> Signature -> WithError (Magic,[Type])
  742. coerceB val ty = case (unifyB (dType val) ty) of
  743.    DFailure s -> DFailure s
  744.    DSucc ([],b) -> DSucc (dValue val,b)
  745.    DSucc (binds,b) -> DSucc ((applyToDicts binds ctxts (dValue val)),b) where
  746.      MkSignature ctxts _ = dType val
  747.  
  748. applyToDicts :: [Type] -> [Context] -> Magic -> Magic
  749. applyToDicts binds ctxts val =
  750.   primApplyList val (map (\(cl,ty) -> fetchDict ty cl)
  751.                          (flattenContext ctxts binds))
  752.  
  753. flattenContext :: [Context] -> [Type] -> [(Class,Type)]
  754. flattenContext [] _ = []
  755. flattenContext ([] : c) (_ : tys) = flattenContext c tys
  756. flattenContext ((cl:cls):cs) t@(ty : _) = (cl,ty) :
  757.                                           flattenContext (cls:cs) t
  758. fetchDict :: Type -> Class -> Magic
  759. fetchDict (BTyvar _ _) _ = error "Ambiguous type"
  760. fetchDict ty cl = applyToDicts subTypes icontext dict where
  761.   Tycon tycon subTypes = ty
  762.   DSucc inst = locateInstance tycon cl
  763.   dict = dInstanceDict inst
  764.   icontext = dInstanceContext inst
  765.  
  766. -- Bogus!! need to re-init modules
  767.  
  768. allInstances :: [Instance]  -- Causes an error if omitted
  769. allInstances = getAllInstances ()
  770.  
  771. -- ------------------------------------------------------------ --
  772. --    Printers for dynamic objects                              -
  773. -- ------------------------------------------------------------ --
  774.  
  775. data PrinterModes {-#STRICT#-} = PrinterModes Bool Bool deriving Text
  776.  
  777. pNonStrict (PrinterModes x _) = x
  778. pAddParens (PrinterModes _ x) = x
  779.  
  780. addP x | pAddParens x = x
  781. addP (PrinterModes x _) = PrinterModes x True
  782. remP x | not (pAddParens x) = x
  783. remP (PrinterModes x _) = PrinterModes x False
  784.  
  785. dShow :: Dynamic -> String
  786. dShow x = sd (PrinterModes False False) x "" 
  787.  
  788. showLazyDynamic :: Dynamic -> String
  789. showLazyDynamic x | dForced x = sd (PrinterModes True False) x ""
  790.                   | otherwise = "#"
  791.  
  792. sd o x s | not (pNonStrict o) && hasText = showT
  793.          | not (dHasDataType x) = showString " @ " s
  794.          | ty == fnType || ty == unitType || ty == intType ||
  795.            ty == integerType || ty == floatType || ty == doubleType ||
  796.            ty == charType = showT
  797.      | stringType (dType x) = if pNonStrict o then
  798.                                   (showChar '"' . showSt slots) s
  799.                                      else
  800.                                       showT
  801.          | ty == listType = showL '[' slots s
  802.          | null constrs = showString "*" s  -- Skolem types
  803.          | dDataTypeRealTuple ty = showTup s
  804.          | otherwise = showGeneric s where
  805.   ty = dDataType x
  806.   showT = case x of (z :: Text a => a) -> shows z s
  807.   stringType t = case t of 
  808.            MkSignature _ (Tycon t1 [Tycon t2 _]) -> t1 == listType && 
  809.                                                 t2 == charType
  810.            _ -> False                           
  811.   constrs = dDataTypeConstrs ty
  812.   constr = dConstructor x
  813.   slots = dSlotsL x
  814.   hasText = case x of (x :: Text a => a) -> True
  815.                       _ -> False
  816.   showGeneric | pAddParens o && (not (null slots))
  817.                           = showChar '(' . showGen1 . showChar ')'
  818.               | otherwise = showGen1
  819.   showGen1 = showString (dConstructorName constr) . showSlots slots
  820.   showSlots [] = id
  821.   showSlots (s:ss) = showChar ' ' . showSlot (addP o) s . showSlots ss
  822.  
  823.   showL c [] = if c == '[' then showString "[]" else showChar ']'
  824.   showL c [car,cdr] = showChar c . showSlot (remP o) car . showCdr cdr
  825.   showCdr (slot,e) | pNonStrict o && (not e) = showString "] ++ #"
  826.                    | otherwise = showL ',' (dSlotsL slot)
  827.   showSt [] = showChar '"'
  828.   showSt [(car,e1),(cdr,e2)] = showChar (if e1 then fromDynamic car else '#') .
  829.                                if e2 then showSt (dSlotsL cdr) else
  830.                                           showString "\" ++ #"
  831.  
  832.   showTup = showChar '(' . showTupSlots slots
  833.   showTupSlots [sl] = showSlot (remP o) sl . showChar ')'
  834.   showTupSlots (sl:ss) = showSlot (remP o) sl . showChar ',' . 
  835.                          showTupSlots ss
  836.  
  837. dSlotsL x = zip (dSlots x) (dSlotsEvaluated x)
  838.  
  839. showSlot o (slot,e) | pNonStrict o && not e = showString "#"
  840.                     | otherwise = sd o slot
  841.  
  842. dForced x = True -- primForced (dValue x)
  843.  
  844. dSlotsEvaluated x | ty == listType = tupleFlags m [False,False]
  845.                   | null strict = []
  846.                   | dDataTypeTuple ty = tupleFlags m strict
  847.                   | otherwise = structFlags m strict  where
  848.   m = dValue x
  849.   c = dConstructor x
  850.   ty = dDataType x
  851.   strict = dConstructorStrictness c
  852.  
  853. -- This ought to use a vector for constant time access.  Used by the
  854. -- code generated to init data struct descriptors.
  855.  
  856. lookupConstr :: Int -> [Constructor] -> Constructor
  857. lookupConstr i (c:cs) = if i == 0 then c else lookupConstr (i-1) cs
  858.  
  859. patternMatchError :: String -> [Dynamic] -> a
  860. patternMatchError s ds = error ("Pattern match failure: " ++ s ++ "\n" ++
  861.    (showString "Arguments:\n" . showArgs ds) "") where
  862.  showArgs [] = id
  863.  showArgs (d:ds) = showString "  " . showString (dShow d) . showChar '\n' .
  864.                    showArgs ds
  865.  
  866.  
  867. -- This stuff implements operations on general structures.  It is called
  868. -- from runtime-types.
  869.  
  870. createLispEnumConstructors :: DataType -> String -> [Magic] -> [Constructor]
  871. createLispEnumConstructors ty str conFns =
  872.    zipWith3 (\s i fn -> 
  873.                  MkConstructor
  874.                    s
  875.                    i
  876.                    NoFixity
  877.                    (MkSignature [] (Tycon ty []))
  878.                    fn
  879.                []
  880.                ty
  881.                []
  882.                    0
  883.                    False)
  884.     (lines str) [0..] conFns
  885.  
  886. createEnumConstructors :: DataType -> String -> [Constructor]
  887. createEnumConstructors ty str =
  888.     zipWith (\s i-> 
  889.                 MkConstructor
  890.                    s
  891.                i
  892.                    NoFixity
  893.                    (MkSignature [] (Tycon ty []))
  894.                    (makeEnumValue i)
  895.                []
  896.                ty
  897.                []
  898.                    0
  899.                    False)
  900.     (lines str) [0..]
  901.  
  902. createConstructors ::
  903.    DataType -> String -> [Class] -> [DataType] -> [[Magic]] -> [Constructor]
  904. createConstructors ty str classes types fns =
  905.  zipWith3 (\s i f-> 
  906.             let [name,fixity,etype,strict,isInfix] = parseOpts s
  907.                 arity = length strict
  908.                 strictness = map (== 'S') strict
  909.                 isTup = dDataTypeTuple ty  in
  910.              MkConstructor
  911.                 name
  912.                 i
  913.             (parseFixity fixity)
  914.                 (parseType etype classes types)
  915.                 (if null f then makeDataConstr isTup i arity strictness
  916.                            else head f)
  917.                 (if null f then makeDataSels isTup arity strictness
  918.                            else tail f)
  919.                 ty
  920.             strictness
  921.             arity
  922.             (isInfix == "I"))
  923.     (lines str) [0..] (if null fns then repeat [] else fns)
  924.  
  925. parseOpts "" = []
  926. parseOpts s = let (l,s') = break (== ';') s in
  927.                 l : if null s' then [] else (parseOpts (tail s'))
  928.  
  929. parseFixity "" = NoFixity
  930. parseFixity [nlr,i] = case nlr of
  931.                        'L' -> InfixL i'
  932.                        'N' -> InfixN i'
  933.                        'R' -> InfixR i'
  934.                       where i' = ord i - ord '0'
  935.  
  936. parseType str classes types = MkSignature ctxts ty where
  937.    ctxts1 :: [[Int]]
  938.    [(ctxts1,str')] = reads str
  939.    ctxts = map (\l -> map (classes !!) l) ctxts1
  940.    (ty,_) = parseType1 str'
  941.    parseType1 s = case s' of
  942.                     ('(':s1) -> (Tycon (types !! i) args,r) where
  943.                                   (args,r) = parseTypeList s1
  944.                     _ -> (Tyvar i,s')
  945.      where [(i,s')] = reads s
  946.            i :: Int
  947.    parseTypeList (')':s1) = ([],s1)
  948.    parseTypeList s1 = (a:args,s2) where
  949.      (a,s3) = parseType1 s1
  950.      (args,s2) = case s3 of
  951.                    (',':s4) -> parseTypeList s4
  952.                    (')':s4) -> ([],s4)
  953.  
  954. makeDataConstr :: Bool -> Int -> Int -> [Bool] -> Magic
  955. makeDataConstr isTup i arity strictness = 
  956.   if isTup then makeGTupleConstr arity strictness
  957.            else makeConstr i arity strictness
  958.  
  959. makeDataSels :: Bool -> Int -> [Bool] -> [Magic]
  960. makeDataSels isTup arity strictness =
  961.   zipWith (\i s -> if isTup then makeGTupleSel i arity s
  962.                             else makeSel i arity s)
  963.       [0..arity-1] strictness
  964.  
  965. makeEnumValue :: Int -> Magic
  966. makeEnumValue i = makeEnumConstr i
  967.  
  968. makeLispConstrFn :: DataType -> [Magic] -> Magic
  969. makeLispConstrFn ty fns =
  970.   toMagic
  971.     (\i -> let f' (c:cs) (f:fs) = 
  972.                 if fromMagic (primApply f i) then c else f' cs fs
  973.             in f' (dDataTypeConstrs ty) fns)
  974.  
  975. makeEnumConstrFn :: DataType -> Magic
  976. makeEnumConstrFn ty = 
  977.  toMagic (\i -> dDataTypeConstrs ty !! enumTypeToInt i)
  978.  
  979. makeGTupleConstrFn :: DataType -> Magic
  980. makeGTupleConstrFn ty = 
  981.   toMagic (\i -> dDataTypeConstrs ty !! tupleTypeToInt i)
  982.  
  983. makeConstrFn :: DataType -> Magic
  984. makeConstrFn ty =
  985.   toMagic (\i -> dDataTypeConstrs ty !! typeToInt i)
  986.